00100	C  SUBRS. VLINE, ASKIT, GRED, LPEN, SAVIT, LISTP ***************
00200	
00300	
00400		SUBROUTINE VLINE(R3,R4,R5,R6)
00500		INTEGER ASK
00600		COMMON /MKX/KSLA,ISEMI,LESS,IGT/A2Z/LAA,LBB,NONO(9),LEL
00700		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /IDEV/IDEV
00800	267 	IF(IDEV.EQ.5)
00900		1 CALL TYPSTR('TYPE STAFF #, POS1, POS2 AND CODE #  ')
01000		READ(IDEV,F78F,END=167)R3,R4,R5,R6
01100	CQQ	ACCEPT F78F,R3,R4,R5,R6
01200		REREAD FA1,ASK
01300		IF(ASK.EQ.LESS)GO TO 167
01400		CALL LO2UP(ASK)
01500		IF(ASK.NE.IGT)GO TO 2
01600		IDEV=1
01700		GO TO 267
01800	2	IF(ASK.EQ.LBB)R3=99
01900	C  99 IS ALSO USED IN MOVER.F4
02000		IF(R3.GE.99)RETURN
02100		IF(ASK.NE.LEL)GO TO 66
02200	C  TYPE 'L' FOR LIGHT-PEN
02300		K=-1
02400	67	R4=RY
02500		CALL LPEN(R3,RY,RX)
02600		REREAD FA1,ASK
02700		CALL LO2UP(ASK)
02800		IF(ASK.EQ.LBB)R3=99
02900		IF(R3.GE.99)RETURN
03000		K=-K
03100		IF(K.GT.0)GO TO 67
03200		R5=RY
03300	C LIGHT PEN IS READ TWICE
03400	66	ASK=-1
03500		IF(R6.LT.100)GO TO 1
03600		R6=R6-100
03700	C  FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
03800		ASK=0
03900	1	CALL BOX(-1,R4)
04000		CALL BOX(-2,R5)
04100	C  PUTS UP TWO VERTICAL LINES
04200		RETURN
04300	CCC3	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
04400	167	IDEV=5    
04500		GO TO 267
04600		END
04700	
04800	
04900		SUBROUTINE ASKIT
05000		INTEGER ASK
05100		COMMON /DPY/ST(4000),MEDIT,IGO/A2Z/NONO(6),LGG
05200		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
05300		COMMON /XRN/RN(1) /KJY/ K,JY
05400		IGO=0
05500		CALL DPYNEW
05600		X=ST(2)
05700		CALL BOX(JY,RN(JY+2))
05800		ST(2)=X
05900	  	CALL TYPSTR('N=NO, <CR>=YES, G=GO  ')
06000		ACCEPT FA1,K
06100		IF(K.EQ.LGG)ASK=-1
06200		CALL DPYNEW
06300		IGO=1
06400		END
06500	
06600		SUBROUTINE GRED
06700		INTEGER PWDS
06800		COMMON /MKX/KSLA,ISEMI,LESS,IGT
06900		1/A2Z/LAA,LBB,NONO(9),LEL,LMM,LNN,NON(9),LXX
07000		COMMON /DPY/IST(4000),MEDIT,IGO /IDEV/IDEV
07100		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /KJY/ K,JY
07200		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
07300		COMMON R2,JA,J,J2,RJQ(6),RC,IZ,RX,KV,RY,IA,IB,C,D,JZ,A,
07400		1 NX,VY,RB,JQ(20) /XRN/RN(1) /ALF/INP(72),ML
07500		COMMON /PTR/PWDS(1) /POSI/STFF(8),JJB,POS
07600		1 /LIMIT/LIMIT,ITEM,L,I,IX
07700		1 /RINP/R(10,80),RPOS(100) /DPTR/IWDS(1)
07800	
07900		EQUIVALENCE (IST2,IST(2))
08000		RC=999
08100		RSTF=RC
08200	CC **CAN'T GET HERE ***IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
08300	C  LEAVES ROUTINE
08400	7	CALL VLINE(R2,Z,POS,RX)
08500	C  PUTS UP TWO VERTICAL LINES
08600		REREAD FA1,NX
08700		CALL LO2UP(NX)
08800		IF(NX.EQ.LBB)GO TO 170
08900		IF(R2.LT.99)GO TO 70
09000	170	JA=98
09100		RETURN
09200	70	IF(POS.EQ.0)POS=200
09300	C  0,0  DOES WHOLE STAFF
09400		IF(INP(1).NE.LAA)GO TO 4
09500	267	IF(IDEV.EQ.1)GO TO 467
09600		CALL TYPSTR(' TYPE P#, CHNG,  P#, CHNG,  P#, CHNG, ...')
09700		CALL TYPCRLF
09800	467	READ(IDEV,F78F,END=167)V
09900	CQQ	ACCEPT F78F,V
10000		REREAD FA1,K
10100	C  TYPE 'L' FOR LIGHT PEN
10200		IF(K.EQ.LESS)GO TO 167
10300		CALL LO2UP(K)
10400		IF(K.NE.IGT)GO TO 367
10500		IDEV=1
10600		GO TO 267
10700	367	IF(V(1).EQ.99)GO TO 7
10800		IF(K.EQ.LBB)GO TO 7
10900	C TYPE 'B' OR 99 TO BACKUP
11000		IF(K.NE.LEL)GO TO 66
11100		DO 67 K=1,2
11200		V(2)=RY
11300		CALL LPEN(V(1),RY,RX)
11400		REREAD FA1,JA
11500		CALL LO2UP(JA)
11600		IF(JA.EQ.LBB)GO TO 7
11700	67	IF(V(1).GE.99)GO TO 7
11800		V(3)=RY
11900	66	JA=0
12000		IZ=0
12100	C  COUNTER
12200		GO TO 14
12300	167	IDEV=5
12400		GO TO 267
12500	4	JA=98
12600	C  FOR DELETIONS
12700	C  STF.N, -99    -- DELETES ALL BUT STAFF N.
12800		IF(Z.NE.-99)GO TO 14
12900		RSTF=R2
13000		R2=99
13100	14	NX=0
13200	C  LOOP STARTS HERE
13300		J=0
13400	140	NX=NX+1
13500	142	JY=PWDS(NX)
13600		RB=RN(JY+3)
13700		IF(RTLINE(JY))GO TO 6
13800		IF(RB.LT.Z)GO TO 6
13900		IF(RB.GT.POS)GO TO 6
14000		IF(RN(JY+2).EQ.RSTF)GO TO 6
14100	C  FOR -99 DELETES.
14200		RB=RN(JY+1)
14300		IF(V(1).EQ.12)GO TO 77
14400		IF(V(1).EQ.100)GO TO 341
14500	C USE P100 AND ANY CODE# TO CREATE CUES. I.E. MINI NOTES, RESTS, BEAMS.
14600		IF(RC.EQ.999)GO TO 143
14700	C  USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
14800	C  SET 12 TO 1 WITH CODE 5 TO INVERT SLURS ONLY
14900	77	RC=0
15000		IF(RB.EQ.5)GO TO 141
15100		IF(RB.NE.6)GO TO 143
15200		IF(RX.EQ.1)GO TO 141
15300	143	IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
15400		IF(ASK)GO TO 100
15500		CALL ASKIT
15600		IF(K.EQ.LNN)GO TO 6
15700		IF(K.EQ.LXX)GO TO 19
15800	100	IF(INP(1).EQ.LAA)GO TO 141
15900		IF(J)GO TO 40
16000		J=-1
16100		K=NX
16200	41	IZ=NX
16300		IF(NX.LT.ITEM)GO TO 140
16400	40	IF(NX-IZ.EQ.1)GO TO 41
16500	C  GO BACK FOR MORE - IF IN RIGHT ORDER.
16600	C  RANGE TO DEL. = K→NX
16700	45	J=IZ+1
16800		IA=PWDS(K)
16900		IB=PWDS(J)-IA
17000		JZ=IWDS(K)
17100		J2=IWDS(J)-JZ
17200		J=J-K
17300		ITEM=ITEM-J
17400		DO 42 IZ=K,ITEM+1
17500		PWDS(IZ)=PWDS(IZ+J)-IB
17600	42	IWDS(IZ)=IWDS(IZ+J)-J2
17700		IST2=IST2-J2
17800		I=I-IB
17900		 CALL LOOP(IA,I,1,0,IB,RN)
18000		CALL LOOP(JZ+2,IST2+2,1,0,J2,IST)
18100		IF(K.GE.ITEM)GO TO 1
18200	C  EXITS
18300		NX=K+1
18400		GO TO 142
18500	341	IF(RB.EQ.6)GO TO 141
18600		IF(RB.GT.2)GO TO 6
18700	141	IF(IZ.GE.97)GO TO 9
18800	C   THERE'S A LIMIT TO THE R ARRAY    4/18/73
18900		IZ=IZ+1
19000	C  FOUND AN ITEM
19100		R(1,IZ)=223
19200	C 223 IS CODE NUMB. FOR EDIT MODE 
19300		R(2,IZ)=NX
19400	10	IZ=IZ+1
19500		DO 101 KV=3,10
19600	101	R(KV,IZ)=0
19700		IF(V(1).NE.100)GO TO 131
19800	231	R(1,IZ)=400
19900	C  MAKES MINI NOTES, RESTS, BEAMS
20000		R(2,IZ)=100
20100		GO TO 6
20200	131	IF(RC.EQ.999)GO TO 11
20300		IF(RB.EQ.1)GO TO 30
20400	31	RC=RN(JY+7)
20500		IF(RB.EQ.6)GO TO 32
20600	C  NEXT INVERTS DIP
20700		IF(RX.EQ.1)GO TO 35
20800		A=-1.6
20900		RB=-10
21000		IF(RC)A=-A
21100	CC***????  WHY CHANGE P2???  ****36	R(7,IZ)=2
21200	CC***	R(8,IZ)=RN(JY+2)+A
21300		GO TO 37
21400	35	RB=-4
21500		IF(RN(JY+8).LT.-1)RB=-1.4
21600	C  2 AND .7 ARE HGTS SET IN 'BEAMS'
21700	37	IF(RC)RB=-RB
21800		R(3,IZ)=4
21900		R(4,IZ)=RN(JY+4)+RB
22000		R(6,IZ)=RN(JY+5)+RB
22100		R(5,IZ)=5
22200	33	R(1,IZ)=7
22300		R(2,IZ)=-RC
22400		GO TO 6
22500	32	IF(RC.LT.20)GO TO 34
22600	C  THIS IS FOR BEAMS
22700	232	RC=10-RC
22800		GO TO 33
22900	132	IF(RC.GT.-20)GO TO 232
23000		GO TO 332
23100	34	IF(RC)GO TO 132
23200	C  P7 IS NEG FOR TREMOLOS
23300	332	RC=-10-RC
23400		GO TO 33
23500	
23600	C  NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
23700	C  MUST! BE FIRST IN LIST!!!
23800	C	RC=0
23900	30	RB=RN(JY+5)
24000		IF(RB.LT.10)GO TO 12
24100	C  NO STEM < 10
24200		RC=10
24300		IF(RB.GE.20)RC=-RC
24400		RB=RB+RC
24500	12	V(1)=5.
24600		V(2)=RB
24700	C  SO IT WILL DISPLAY RESULT
24800	11	DO 8 K=1,10
24900	8	R(K,IZ)=V(K)
25000	6	IF(J)GO TO 45
25100		IF(NX.LT.ITEM)GO TO 140
25200	19	IF(INP(1).NE.LAA)GO TO 1
25300	9	R(1,IZ+1)=222
25400		R(1,IZ+2)=0
25500	CC	REND=-1.
25600	1	CALL HYDPOG(3)
25700		END
25800	
25900		SUBROUTINE LPEN(A,B,C)
26000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /SIZ/RSZ,JCEN,KCEN
26100		COMMON /POSI/STFF(0/7),JJ2,POS /ALF/INP(71),M,L /C/MM,LL
26200		COMMON /A2Z/LAA,LBB,NONO(21),LXX
26400		M=MM
26500		L=LL
26600		IF(IABS(M).GT.512)GO TO 4
26700		IF(IABS(L).LE.512)GO TO 3
26800	4	M=0
26900		L=100
27000	3	CALL SETCUR(M,L,0)
27100		CALL TYPSTR('TYPE <CR> TO SET POINT')
27200		ACCEPT FA1,JD
27300		IF(JD.EQ.'9')RETURN
27400		IF(JD.EQ.LXX)RETURN
27500	C  TYPE 'B' OR 99 TO BACK UP
27600		IF(JD.EQ.LBB)RETURN
27700		CALL RDCUR(M,L)
27900		L=(L+KCEN)/RSZ
28000	1	B=((M+JCEN)/RSZ+596.0)/5.96
28100	C  B=HORIZ. STEP NUM.
28200		DO 13 K=0,7
28300		M=STFF(K)+60.
28400		IF(L.GT.M)GO TO 13
28500		A=K
28600	C  A=STAFF NUM.
28700		GO TO 8
28800	13	CONTINUE
28900	8	C=IFIX((L-STFF(K)+21.)/7.+.5)
29000	C  FINDS VERT. NOTE NUM.
29100		TYPE F78F,A,B
29200		END
29300	
29400	
29500		SUBROUTINE SAVIT
29600		IMPLICIT INTEGER(A-Q,S-Z)
29700		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/DL/X22,SAVER,NAME,EXT
29800		1 /POSI/STFF(0/7),JJ2,IPOS /LIMIT/LIMIT,ITEM,L,I,IX 
29900		1 /SCM/V(78),ISCR,LCNT,IRSTF,LIST(200),REND 
30000		1 /ALF/INP(72),ML/XRN/RN(1)/DPY/ST(4000),MEDIT,IGO
30100		1 /STF/RSTFAC(0/7),RSTJ2 /PTR/PWDS(1) /JCHAR/IXX,ISEMI,IBLA
30200		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
30300		COMMON /A2Z/LAA,LBB,LCC,LDD,NONO(8),LMM,LNN,NON(4),LSS
30500		DIMENSION SV(128)
30600		EQUIVALENCE (INP2,INP(2)),(ST2,ST(2)),(SV,LIST)
30700	C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE TMP.DMD
30800		KX=-1
30900		K=0
31000	32	K=K+1
31100	C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
31200	33	L=PWDS(K)
31300		IA=PWDS(K+1)
31400		IB=RN(L)+3.+L
31500	C  THIS SHOULD BE NEW POINTER
31600		IF(IA-IB.EQ.0)GO TO 36
31700		IF(RN(IB)+3+IB.NE.PWDS(K+2))GO TO 38
31800		J=K+1
31900		PWDS(J)=IB
32000		CALL TYPSTR('?FIXED UP ITEM ')
32100		CALL TYPINT(J)
32200		CALL TYPCRLF
32300		GO TO 36
32400	38	IJ=IA-L
32500		DO 39 J2=K+1,ITEM
32600	39	PWDS(J2)=PWDS(J2+1)-IJ
32700		CALL TYPSTR('BAD ITEM--')
32800		CALL TYPINT(K)
32900		CALL TYPCRLF
33000		IF(KX.EQ.0)GO TO 50
33100		CALL TYPSTR('NAME.EXT? ')
33300		ACCEPT 141,INP
33400		CALL NAMEXT(INP,NAME,EXT)
33500	C  ONLY DOES THIS ON THE FIRST ERROR
33600		GO TO 2
33700	50	J=RJ
33800		KX=0
33900		CALL LOOP(L,I,1,0,J,RN)
34000	C  REARRANGES DATA
34100		I=I-J
34200		ITEM=ITEM-1
34300		IF(ITEM.LE.K)GO TO 37
34400		GO TO 33
34500	C  GO BACK AND TRY AGAIN
34600	36	IF(IA.LE.L)GO TO 38
34700	C  JUMP IF PWDS IS OUT OF ORDER
34800		IF(K.LT.ITEM)GO TO 32
34900	37	KX=-1
35000		IF(SAVER.GE.0)GO TO 10
35200		SAVER=5
35300	101	CALL PUTEXT('TMP','DMD')
35400		GO TO 102
35500	1	FORMAT(I,24F)
35600	2	CALL TYPCHR('WRITE OVER   ',13)
35700		CALL TYPWRD(NAME)
35800		CALL TYPCHR('.',1)
35900		CALL TYPCHR(EXT,3)
36000		CALL TYPCHR('?  ',3)
36300		ACCEPT 141,INP
36350		CALL LULOOP
36400		IF(INP(1).NE.LNN)GO TO 4
36800	10	IF(INP2.EQ.LMM)GO TO 4
36900	11	L=NAME
37000		INP(1)=-1
37100		CALL NAMEXT(INP,NAME,EXT)
37300		IF(NAME.NE.IBLA)GO TO 40
37400		CALL TYPSTR('NAME.EXT? ')
37600		ACCEPT 141,INP   
37700		CALL NAMEXT(INP,NAME,EXT)
37800		IF(NAME.EQ.IBLA)GO TO 4
38000	C 99 WILL BACK UP.
38100		IF(NAME.NE.'99')GO TO 40
38200		NAME=L
38300		RETURN
38400	40	IF(NAME.NE.'SAME')GO TO 43
38500		NAME=L
38600		GO TO 4
38700	141	FORMAT(72A1)
39000	43	IF(LOOKX(NAME,EXT))GO TO 2
39100	C  JUMP BACK IF FILE NAME ALREADY ON DSK
39200	4	IF(KX.EQ.0)GO TO 50
39400		IF(NAME.NE.IBLA)GO TO 41
39500		NAME=L
39600		GO TO 101
39800	41	CALL PUTEXT(NAME,EXT)
40100	42	IF(INP2.EQ.LDD)GO TO 202
40200	C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
40300	102	IRSTF=0
40400		IF(INP2.EQ.LBB)IRSTF=-1
40500		JJ2=ITEM+2
40600		IPOS=I
40700	C WD CNTS
40800		CALL EXTOUT(RSTFAC,128)
40900	C  INCLUDES STFF AND V ARRAYS
41000		CALL EXTOUT(PWDS,JJ2)
41100		CALL EXTOUT(RN,IPOS)
41200		IF(LCNT.GT.1)CALL EXTOUT(LIST,LCNT)
41300	CC102	WRITE(21)ITEM,I
41400	CC	1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
41500	CC	1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,SV
41600	C (SV) FOR FORTRAN READ BUG!!!!
41700	CC	IF(SAVER.GE.0)WRITE(21)RSTFAC,STFF,L
41800	C NOT USED WHEN SAVE IS AUTOMATIC.
41900	C  TAKE OUT ABOVE WHEN BUG IS SOMEDAY FIXED IN F4.
42000		IF(I.LE.LIMIT)GO TO 20
42100		CALL TYPSTR('****** TOO MUCH DATA TO PRINT - ')
42200		CALL TYPINT(I)
42300		CALL TYPCHR('/',1)
42400		CALL TYPINT(LIMIT)
42600	20	IF(INP2.EQ.LBB)CALL EXTOUT(ST,4302)
42900	1001	CALL FINEXT
43000		IF(INP(1).NE.LSS)RETURN
43200		IF(NAME.NE.IBLA)RETURN
43300		CALL TYPSTR('DISPLAY SAVED IN "TMP.DMD"')
43400		CALL TYPCRLF
43500	C   GO BACK IF THE SAVER WROTE THE FILE
43600		RETURN
43700	202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
43800	 	GO TO 1001
43900	C   WRITES DPY BUFFER ONLY.
44000		END
44100	
44200		SUBROUTINE LISTP(LST)
44300		IMPLICIT INTEGER(A-Q,S-Z)
44400		DIMENSION LST(1)
44500		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
44600		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),K,JY,X,Y /XRN/RN(1)
44700		1 /STF/RSTFAC(0/7),RSTJ2 /LIMIT/LIMIT,ITEM,L,I,IX /PTR/PWDS(1)
44800		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(RJC,RJQ(1)),(RJD,RJQ(2))
44900	
45000		CALL NOZERO(R2)
45100		JC=RJC
45200		IF(JC.EQ.0)JC=ITEM
45300		JY=5
45400		JD=RJD
45500		IF(JD.NE.0)JY=3
45600		DO 6334 L=IFIX(R2),JC
45700		X=PWDS(L)
45800		Y=RN(X)+2+X
45900		X=X+1
46000		K=RN(X)
46400	6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
46500	C  P, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
46600	C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
46800	6333	FORMAT(I4,') ',A5,2F4.0,F8.3,F8.2,7F10.2)
46900		END